﻿\ 8 queens

\ http://forthfreak.net/index.cgi?EightQueens

\ Triangular array of bitmasks, one bit per square
\  recursion depth 0, ranks 0..N-1 are at offsets 0..N-1
\  recursion depth 1, ranks 1..N-1 are at offsets N..N+(N-1)-1
\  etc.
12 constant maxN
8 value N
create ranks maxN dup 1+ * 2/ cells allot
: init_ranks
  1 N lshift 1-  N 0 do dup ranks I cells + ! loop drop ;

: lowBit  ( mask -- bit ) dup negate and ;
: lowBit- ( mask -- bits ) dup 1- and ;

: .sq   1 and if [char] Q else [char] . then space emit ;
: .rank ( mask -- ) N 0 do dup .sq 2/ loop drop cr ;
: .solution	\ a solution is encoded in ranks
  N ranks begin
    dup @ lowBit .rank
    over cells +  swap 1- swap
  over 0= until 2drop cr ;
: .ranks ( addr count -- )
  0 do dup I cells + @ .rank loop drop cr ;

: dmask ( fm r -- fdm ) \ mask for file and diagonals
  >R  dup R@ lshift or  dup R> rshift or ;

\ Copy the square availability from the current ranks
\ to the next ranks, excluding attacks by the new queen
\ at nextBit of ^rank.
\ Aborts if there is no possible solution from here.

variable excludes  \ N=8 should be 4380
variable nodes     \ N=8 should be 1073
variable solutions \ N=8 should be 92

: exclude ( ranksLeft ^rank -- tf )
  over 1- cells over + swap rot ( dest src ranksLeft )
  1 do   1 excludes +!
    2dup dup @ lowBit ( dest src mask ) \ file
     dup I lshift or		\ left diagonal
     dup I rshift or invert	\ right diagonal
    swap I cells + @ and        ( dest masked )
    dup 0= if 2drop 2drop unloop false exit then
    swap I cells + !
  loop 2drop true ;

: tryRank ( ranksLeft ^rank -- ) 1 nodes +!
  begin
    over 1- if
      2dup exclude if
        over 1- 2dup 1+ cells + recurse
      then
    else ( .solution)  1 solutions +! then
    dup @ lowBit-  dup
  while  over !
  repeat drop 2drop ;

: queens ( n -- ) to N  cr
  init_ranks  0 solutions ! 0 nodes ! 0 excludes !
  N ranks tryRank
  N . ." queens: " solutions @ . ." solutions, "
  nodes @ . ." nodes, " excludes @ . ." exclude loops" ;

: test-queens   maxN 0 do CR TIME&DATE . . . . . . CR I 1+ queens loop CR TIME&DATE . . . . . . CR ;
